Shareware Grab Bag/Shareware Grab Bag.iso/090/pctjoc85.arc/SLIMFISH.PAS

Pascal/Delphi Source File | 1985-03-11 | 22KB | 818 lines

{ WA-TOR program -- Inspired by Scientific American, 12/84 }

{$debug-}
{$entry-}
{$line-}

PROGRAM wator(input,output) ;

  { ms-pascal library functions }

  FUNCTION dosxqq(command: byte; parm: word): byte ;
    EXTERN ;

  { assembly language utilities }

  PROCEDURE set_cursor(row,column: integer) ;
    EXTERN ;

  PROCEDURE cursor_disappear ;
    EXTERN ;

  PROCEDURE cursor_reappear ;
    EXTERN ;

  PROCEDURE clear_screen ;
    EXTERN ;

  TYPE
    byte_address = ads of byte ;

  PROCEDURE blast_video_ram(address: byte_address ;
                            output_byte: byte) ;
    EXTERN ;

  FUNCTION equipment: word ;
    EXTERN ;

  FUNCTION tics : word ;
    EXTERN ;

  PROCEDURE install_break_handler ;
    EXTERN ;

  FUNCTION check_break : boolean ;
    EXTERN ;

  PROCEDURE remove_break_handler ;
    EXTERN ;

  CONST

    { video attributes }

    normal = 7 ;
    intense = 15 ;

    { keyboard codes }

    enter = #D ;
    backspace = #8 ;
    blank = #20 ;

    { describe the size of the wator world }

    xsize = 79 ;                       { horizontal size of wator  }
    maxx = 78 ;                        { xsize -1                  }
    ysize = 20 ;                       { vertical size of wator    }
    maxy = 19 ;                        { ysize -1                  }
    max_beings = (xsize*ysize)+4 ;     { maximum beings of wator   }

  TYPE

    { describe the fish lists used to keep track of wator's beings }

    species = (fish,shark,empty) ;
    xcoord = 0..maxx ;
    ycoord = 0..maxy ;
    link = ADR of fishes ;
    fishes = RECORD
               next : link ;
               prev : link ;
               kind : species ;
               age : integer ;
               x : xcoord ;
               y : ycoord ;
               ate : integer ;
             END ;

    { identify the neighbors of a given fish or shark }

    neighbor = RECORD
                 x : integer ;
                 y : integer ;
                 kind : species ;
               END ;
    neighborhood = ARRAY [1..8] OF neighbor ;

    { video screen types }

    video_position = RECORD
                       character: char ;
                       attribute: byte ;
                     END;
    video_ram_type = ARRAY [1..25,1..80] of video_position ;

  VAR

    { free pool of sharks and fishes }

    free_pool : ARRAY [1..max_beings] of fishes ;

    { head free pool of sharks and fishes }

    free_pool_head : link ;

    { heads and tails of the lists of beings on wator }

    fish_head : link ;
    fish_tail : link ;
    shark_head : link ;
    shark_tail : link ;

    { array to identify what is currently at a place in wator }

    pond : ARRAY [xcoord,ycoord] OF species ;

    { variables that describe the characteristics of wator }

    nfishes : integer ;           { init number of fishes in pond  }
    nsharks : integer ;           { init number of sharks in pond  }
    sbreed : integer ;            { chronons btwn shark breeding   }
    fbreed : integer ;            { chronons btwn fish  breeding   }
    starve : integer ;            { time a shark can go w/o eating }

    { miscellaneous variables }

    generation : integer ;
    counts : ARRAY [fish..shark] OF integer ;
    neighbors : ARRAY [1..4] OF neighbor ;
    abort : boolean ;
    seed : word ;
    monochrome_adapter : boolean ;
    video_ram : ADS of video_ram_type ;
    screen_string : lstring(80) ;

    { interface to pascal's runtime ctrl to manage data seg size   }

    datsqq [PUBLIC] : word;       { size of wator's data segment   }

  VALUE

    { maximum size of pascal's data segment in paragraphs }

    datsqq := 1536;               { 1536 paragraphs = 24K bytes    }

  { utility to concatenate two strings together }

  PROCEDURE concat_string(var target: lstring ;
                          const source: string) ;
    VAR
      length : integer ;
      i: integer ;

    BEGIN
      length := upper(source) ;
      IF length > upper(target) - ord(target.len) THEN
        length := upper(target) - ord(target.len) ;
      IF length <> 0 THEN
        BEGIN
          FOR i := 1 to length DO
            target[ord(target.len) + i] := source[i] ;
          target.len := target.len + wrd(length) ;
        END ;
    END ;

  { utility to concatenate an integer to a string }

  PROCEDURE concat_integer_to_string(var target: lstring;
                                     source: integer) ;

    VAR
      i : integer ;
      temp : integer4 ;
      new_char : char ;

    BEGIN
      IF source < 0 THEN
        concat_string(target,'0')
      ELSE
        BEGIN
          temp := 100000000 ;
          WHILE temp > source DO
            temp := temp DIV 10 ;
          WHILE temp > 1 DO
            BEGIN
              new_char := chr(ord(source DIV temp) + ord('0')) ;
              concat_string(target,new_char) ;
              source := ord(source MOD temp) ;
              temp := temp DIV 10 ;
            END ;
          new_char := chr(ord(source) + ord('0')) ;
          concat_string(target,new_char) ;
      END ;
    END ;

  { utility to convert a string into an integer }

  FUNCTION string_to_integer(const source: string): integer ;

    VAR
      i,n : integer ;

    BEGIN
      n := 0 ;
      FOR i := 1 TO upper(source) DO
        BEGIN
          IF (source[i] < '0') OR (source[i] > '9') THEN
            BEGIN
              string_to_integer := 0 ;
              RETURN ;
            END ;
          n := n * 10 + ord(source[i]) - ord('0') ;
        END ;
      string_to_integer := n ;
    END ;

  { screen display utility }

  PROCEDURE display_string(row,column : integer ;
                           const output_string : lstring ;
                           attrib : byte);
    VAR
      i : integer ;

    BEGIN

      { update monochrome adapter video ram fast w/o sync }

      IF monochrome_adapter THEN
      FOR i := 1 to ord(output_string.len) DO
        BEGIN
          video_ram^[row,column+i-1].character := output_string[i] ;
          video_ram^[row,column+i-1].attribute := attrib ;
        END

      { sync while updating color adapter video ram to avoid snow }

      ELSE FOR i := 1 to ord(output_string.len) DO
        BEGIN
          blast_video_ram(ADS video_ram^[row,column+i-1].character,
                          wrd(output_string[i])) ;
          blast_video_ram(ADS video_ram^[row,column+i-1].attribute,
                          attrib) ;
        END ;
    END ;

  { number display utility }

  PROCEDURE display_number(row,column,number : integer ;
                           attrib : byte);
    VAR
      i : integer ;

    BEGIN
      display_string(row,column,'      ',attrib);
      screen_string := ' ';
      concat_integer_to_string(screen_string,number) ;
      display_string(row,column,screen_string,attrib) ;
    END ;

  { utility to get the next keystroke }

  FUNCTION get_next_key : char ;

    VAR
      key_code: byte;

    BEGIN
      key_code := dosxqq(1,0) ;
      IF (key_code = 0) THEN
        key_code := dosxqq(1,0);
      get_next_key := chr(key_code);
    END;

  { utility to get an integer from the keyboard }

  FUNCTION get_integer: integer ;

    VAR
      key: char ;
      input_string: lstring(80);

    BEGIN
      input_string.len := 0;
      key := get_next_key ;
      WHILE (key <> chr(enter)) AND (input_string.len <= 80) DO
        BEGIN
          IF (key = chr(backspace)) AND
             (input_string.len > 0) THEN
            BEGIN
              eval(dosxqq(2,blank));
              eval(dosxqq(2,backspace));
              input_string.len := input_string.len - 1;
            END
          ELSE
            BEGIN
              input_string.len := input_string.len + 1;
              input_string[ord(input_string.len)] := key;
            END;
          key := get_next_key ;
        END;
      get_integer := string_to_integer(input_string);
    END;

  { random number generator }

  FUNCTION random(max_index:integer) : integer ;

    VAR
      product : integer4 ;

    BEGIN
      product := 1433 * ord(seed) ;
      seed := wrd(product) + 1847;
      random := ord(seed mod wrd(max_index)) ;
    END ;

  { allocate a shark or fish from the fish pool }

  FUNCTION allocate_fish: link ;

    BEGIN
      allocate_fish := free_pool_head ;
      free_pool_head := free_pool_head^.next ;
    END ;

  { free a shark or fish back to the fish pool }

  PROCEDURE free_fish(fish_p : link) ;

    BEGIN
      fish_p^.next := free_pool_head ;
      free_pool_head := fish_p ;
    END ;

  { utility function to implement universe wrapping }

  FUNCTION wrap(c,l:integer) : integer ;

    BEGIN
      c := c MOD l ;
      IF c < 0 THEN
        c := c + l ;
      wrap := c ;
    END ;

  { procedure to display a fish (or water) at a given location }

  PROCEDURE display_fish(x:xcoord ;
                         y:ycoord ;
                         t:species) ;

    BEGIN
      IF t = fish THEN
        BEGIN
          display_string(y+1,x+1,',',normal);
        END
      ELSE IF t = shark THEN
        BEGIN
          display_string(y+1,x+1,'δ',intense);
        END
      ELSE
        display_string(y+1,x+1,' ',normal);
      pond[x,y] := t ;
    END ;

  { procedure to add a new fish (or shark) to the pond }

  PROCEDURE add_fish(p:link ;
                     p_kind:species ;
                     p_x:xcoord ;
                     p_y:ycoord) ;

    VAR
      t : link ;

    BEGIN
      t := allocate_fish ;
      counts[p_kind] := counts[p_kind] + 1 ;
      WITH t^ DO
        BEGIN
          next := p^.next ;
          prev := p ;
          kind := p_kind ;
          age := 0 ;
          x := p_x ;
          y := p_y ;
          ate := 0 ;
          display_fish(p_x,p_y,p_kind) ;
        END ;
      p^.next^.prev := t ;
      p^.next := t ;
    END ;

  { procedure to delete an entry from a fish list }

  PROCEDURE delete_fish(p:link) ;

    BEGIN
      WITH p^ DO
        BEGIN
          counts[p^.kind] := counts[p^.kind] - 1 ;
          prev^.next := next ;
          next^.prev := prev ;
          display_fish(x,y,empty) ;
          free_fish(p) ;
        END ;
    END ;

  { procedure to check the pond around a given fish/shark }

  PROCEDURE check_pond(p_x:xcoord ;
                       p_y:ycoord ;
                       t:species ;
                       VAR n:integer ;
                       VAR a:neighborhood) ;

    VAR
      tx : xcoord ;
      ty : ycoord ;
      i : integer ;

    BEGIN
      n := 0 ;
      FOR i := 1 TO 4 DO
        BEGIN
          tx := wrap(p_x+neighbors[i].x,xsize) ;
          ty := wrap(p_y+neighbors[i].y,ysize) ;
          IF pond[tx,ty] = t THEN
            BEGIN
              n := n + 1 ;
              WITH a[n] DO
                BEGIN
                  x := tx ;
                  y := ty ;
                  kind := pond[tx,ty] ;
                END ;
            END ;
        END ;
    END ;

  { procedure to make fish swim }

  PROCEDURE fish_swim ;

    VAR
      f_link : link ;
      f_n : integer ;
      f_nghbr : neighborhood ;
      old_x : xcoord ;
      old_y : ycoord ;
      r : integer ;

    BEGIN
      f_link := fish_head^.next ;
      WHILE (f_link <> fish_tail) DO
        WITH f_link^ DO
          BEGIN
            IF check_break THEN
              BEGIN
                abort := true ;
                break ;
              END;
            check_pond(x,y,empty,f_n,f_nghbr) ;
            IF f_n > 0 THEN
              BEGIN
                old_x := x ;
                old_y := y ;
                r := random(f_n) + 1 ;
                display_fish(x,y,empty) ;
                x := f_nghbr[r].x ;
                y := f_nghbr[r].y ;
                display_fish(x,y,fish) ;
                IF age >= fbreed THEN
                  BEGIN
                    add_fish(fish_head,fish,old_x,old_y) ;
                    age := 0 ;
                  END
                ELSE
                  age := age + 1 ;
              END
            ELSE
              age := age + 1 ;
            f_link := next ;
          END ;
    END ;

  { procedure where a fish turns into a shark nummy }

  PROCEDURE eat_fish(p_x:xcoord ;
                     p_y:ycoord) ;

    VAR
      f_link : link ;
      eaten : boolean ;

    BEGIN
      eaten := false ;
      f_link := fish_head^.next ;
      WHILE (f_link<>fish_tail) AND ( NOT eaten) DO
        WITH f_link^ DO
          IF (x = p_x) AND (y = p_y) THEN
            BEGIN
              delete_fish(f_link) ;
              eaten := true ;
            END
          ELSE
            f_link := next ;
    END ;

  { shark hunt and breeding procedure }

  PROCEDURE shark_move ;

    LABEL
      next_shark ;

    VAR
      s_link : link ;
      s_n : integer ;
      s_nghbr : neighborhood ;
      old_x : xcoord ;
      old_y : ycoord ;
      r : integer ;

    BEGIN
      s_link := shark_head^.next ;
      WHILE (s_link <> shark_tail) DO
        WITH s_link^ DO
          BEGIN
            IF check_break THEN
              BEGIN
                abort := true;
                break;
              END;

            { feeding section }

            check_pond(x,y,fish,s_n,s_nghbr) ;
            IF s_n > 0 THEN
              BEGIN
                old_x := x ;
                old_y := y ;
                r := random(s_n) + 1 ;
                display_fish(x,y,empty) ;
                x := s_nghbr[r].x ;
                y := s_nghbr[r].y ;
                eat_fish(x,y) ;
                display_fish(x,y,shark) ;
                ate := 0 ;
                IF age >= sbreed THEN
                  BEGIN
                    add_fish(shark_head,shark,old_x,old_y) ;
                    age := 0 ;
                  END
                ELSE
                  age := age + 1 ;
                s_link := next ;
                GOTO next_shark ;
              END ;

            { starvation section }

            ate := ate + 1 ;
            IF ate > starve THEN
              BEGIN
                screen_string := 'shark at position (';
                concat_integer_to_string(screen_string,y+1);
                concat_string(screen_string,',');
                concat_integer_to_string(screen_string,x+1);
                concat_string(screen_string,') starved...');
                display_string(ysize+5,41,screen_string,normal);
                s_link := next ;
                delete_fish(s_link^.prev) ;
                GOTO next_shark ;
              END ;

            { move to unoccupied section }

            check_pond(x,y,empty,s_n,s_nghbr) ;
            IF s_n > 0 THEN
              BEGIN
                old_x := x ;
                old_y := y ;
                r := random(s_n) + 1 ;
                display_fish(x,y,empty) ;
                x := s_nghbr[r].x ;
                y := s_nghbr[r].y ;
                display_fish(x,y,shark) ;
                IF age >= sbreed THEN
                  BEGIN
                    add_fish(shark_head,shark,old_x,old_y) ;
                    age := 0 ;
                  END
                ELSE
                  age := age + 1 ;
                s_link := next ;
                GOTO next_shark ;
              END ;

            { if we get here, the shark just gets older }

            age := age + 1 ;
            s_link := next ;
            GOTO next_shark ;
next_shark:
          END ;
    END ;

  { wator initialization procedure }

  PROCEDURE init_wator ;

    VAR
      i : integer ;
      tx : xcoord ;
      ty : ycoord ;
      tt : boolean ;

    BEGIN
      display_string(1,1,'Welcome to WA-TOR.',normal) ;
      display_string(3,1,'How many fishes does WA-TOR have?',
                     normal) ;
      display_string(4,1,'Pick a number between 1..1000.  Try 200.',
                     normal) ;
      set_cursor(4,0);
      i := get_integer;
      IF (i>1000) OR (i<1) THEN
        nfishes := 200
      ELSE
        nfishes := i ;

      display_string(6,1,'How many sharks does WA-TOR have?',
                     normal) ;
      display_string(7,1,'Pick a number between 1..200.  Try 20.',
                     normal) ;
      set_cursor(7,0);
      i := get_integer;
      IF (i>200) OR (i<1) THEN
        nsharks := 20
      ELSE
        nsharks := i ;

      display_string(9,1,'How often do the fish breed?',normal) ;
      display_string(10,1,
        'Pick a number between 1..100 chronons.  Try 3 chronons.',
                     normal) ;
      set_cursor(10,0);
      i := get_integer;
      IF (i>100) OR (i<1) THEN
        fbreed := 3
      ELSE
        fbreed := i ;

      display_string(12,1,'How often do the sharks breed?',normal) ;
      display_string(13,1,
        'Pick a number between 1..100 chronons.  Try 10 chronons.',
                     normal) ;
      set_cursor(13,0);
      i := get_integer;
      IF (i>100) OR (i<1) THEN
        sbreed := 10
      ELSE
        sbreed := i ;

      display_string(15,1,'How long can a shark go without eating?',
                     normal) ;
      display_string(16,1,
        'Pick a number between 1..100 chronons.  Try 3 chronons.',
                     normal) ;
      set_cursor(16,0);
      i := get_integer;
      IF (i>100) OR (i<1) THEN
        starve := 3
      ELSE
        starve := i ;
      cursor_disappear;
      clear_screen;
      display_string(ysize+2,1,'fishes     =',normal);
      display_string(ysize+3,1,'sharks     =',normal);
      display_string(ysize+4,1,'generation =',normal);

      screen_string := 'fish breed every ';
      concat_integer_to_string(screen_string,fbreed);
      concat_string(screen_string,' chronons');
      display_string(ysize+2,41,screen_string,normal);

      screen_string := 'sharks breed every ';
      concat_integer_to_string(screen_string,sbreed);
      concat_string(screen_string,' chronons');
      display_string(ysize+3,41,screen_string,normal);

      screen_string := 'sharks starve after ';
      concat_integer_to_string(screen_string,starve);
      concat_string(screen_string,' chronons');
      display_string(ysize+4,41,screen_string,normal);

      display_string(ysize+5,1,'Press Ctrl-Break to end WA-TOR...',
                     normal) ;
      abort := false;
      seed := tics ;
      neighbors[1].x := 0 ;
      neighbors[1].y := - 1 ;
      neighbors[2].x := - 1 ;
      neighbors[2].y := 0 ;
      neighbors[3].x := 1 ;
      neighbors[3].y := 0 ;
      neighbors[4].x := 0 ;
      neighbors[4].y := 1 ;

      { initialize free list of sharks and fishes }

      free_pool_head := ADR free_pool[1] ;
      FOR i := 1 to (max_beings-1) DO
          free_pool[i].next := ADR free_pool[i+1] ;

      { setup allocated lists of sharks and fishes }

      fish_head := allocate_fish ;
      fish_tail := allocate_fish ;
      shark_head := allocate_fish ;
      shark_tail := allocate_fish ;
      fish_head^.next := fish_tail ;
      fish_tail^.prev := fish_head ;
      shark_head^.next := shark_tail ;
      shark_tail^.prev := shark_head ;
      counts[fish] := 0 ;
      counts[shark] := 0 ;
      generation := 1 ;
      FOR tx := 0 TO maxx DO
        FOR ty := 0 TO maxy DO
          pond[tx,ty] := empty ;
      FOR i := 1 TO nfishes DO
        BEGIN
          tt := true ;
          WHILE tt DO
            BEGIN
              tx := random(xsize) ;
              ty := random(ysize) ;
              IF pond[tx,ty] = empty THEN
                BEGIN
                  add_fish(fish_head,fish,tx,ty) ;
                  fish_head^.next^.age := random(fbreed) ;
                  tt := false ;
                END ;
            END ;
        END ;
      FOR i := 1 TO nsharks DO
        BEGIN
          tt := true ;
          WHILE tt DO
            BEGIN
              tx := random(xsize) ;
              ty := random(ysize) ;
              IF pond[tx,ty] = empty THEN
                BEGIN
                  add_fish(shark_head,shark,tx,ty) ;
                  WITH shark_head^.next^ DO
                    BEGIN
                      age := random(sbreed) ;
                      ate := random(starve) ;
                    END ;
                  tt := false ;
                END ;
            END ;
        END ;
    END ;

  { hardware initialization procedure }

  PROCEDURE init_hardware ;

    BEGIN
      clear_screen ;
      set_cursor(0,0) ;
      monochrome_adapter := ((equipment AND 16#30) = 16#30) ;
      IF monochrome_adapter THEN
        video_ram.s := 16#B000
      ELSE video_ram.s := 16#B800 ;
      video_ram.r := 0 ;
    END ;

  { main program }

  BEGIN
    init_hardware ;
    init_wator ;
    install_break_handler ;
    WHILE ((fish_head^.next <> fish_tail) OR
          (shark_head^.next <> shark_tail)) AND
          (NOT abort) DO
      BEGIN
        display_number(ysize+2,14,counts[fish],normal);
        display_number(ysize+3,14,counts[shark],normal);
        display_number(ysize+4,14,generation,normal);
        fish_swim ;
        shark_move ;
        generation := generation + 1 ;
      END;
    remove_break_handler ;
    clear_screen ;
    IF (fish_head^.next = fish_tail) AND
       (shark_head^.next = shark_tail) THEN
      display_string(1,1,'All life on WA-TOR extinct...',normal) ;
    set_cursor(0,0) ;
    cursor_reappear ;
  END.